;; Copyright (c) 2012, 2013 Alan Watson. All rights reserved.

;; BSD-style license: http://synthcode.com/license.txt

;;> \title{Library (clock leap-seconds-list)}
;;
;;> This library maintains a list of leap seconds.
;;>
;;> The library offers a means to
;;> automatically update the list from an external source. Such automatic
;;> updates are useful in long-running programs, since leap seconds
;;> are typically only announced a few weeks or months in advance.

(define-library (clock leap-seconds-list)

  (export leap-seconds-before-utc-day-alist
          leap-seconds-before-tai-second-alist
          set-open-leap-seconds-list-port!
          set-update-exception-handler!)

  (import (scheme base))
  (import (scheme file))
  (import (scheme read))
  (import (scheme process-context))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (import (srfi 18))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (cond-expand

   ;; We ensure thread-safe atomic access to mutated bindings using atomic
   ;; boxes.

   (chibi
    (begin

      ;; This implementation relies on record accessors and mutators being
      ;; atomic in Chibi Scheme.

      (define-record-type atomic-box-record-type
        (make-atomic-box value)
        atomic-box?
        (value atomic-box-value atomic-box-value-set!))))

   (else
    (begin

      ;; This implementation uses SRFI-18 mutexes.

      (define (make-atomic-box value)
        (let ((mutex (make-mutex)))
          (mutex-specific-set! mutex value)
          mutex))

      (define atomic-box? mutex?)

      (define (atomic-box-value mutex)
        (mutex-lock! mutex)
        (let ((value (mutex-specific mutex)))
          (mutex-unlock! mutex)
          value))

      (define (atomic-box-value-set! mutex value)
        (mutex-lock! mutex)
        (mutex-specific-set! mutex value)
        (mutex-unlock! mutex)))))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (begin

    (define seconds-per-day (* 24 60 60))

    ;;> \procedure{(leap-seconds-before-utc-day-alist)}
    ;;>
    ;;> Returns an alist whose cars are the number of UTC days since
    ;;> 1970-01-01 00:00:00 UTC and whose cdrs are the corresponding number
    ;;> of leap seconds prior to that day. The alist is ordered by
    ;;> decreasing cdr. Both the cars and cdrs are exact integers.
    ;;>
    ;;> As of 2014, the first three pairs of the alist are
    ;;> \scheme{(15522 . 25)},
    ;;> \scheme{(14245 . 24)}, and
    ;;> \scheme{(13149 . 23)}
    ;;> and the last three pairs are
    ;;> \scheme{(1096 . 2)},
    ;;> \scheme{(912 . 1)}, and
    ;;> \scheme{(730 . 0)}.

    (define (leap-seconds-before-utc-day-alist)
      (atomic-box-value utc-day-alist-box))

    ;;> \procedure{(leap-seconds-before-tai-second-alist)}
    ;;>
    ;;> Returns an alist whose cars are the number TAI seconds since
    ;;> 1970-01-01 00:00:00 TAI and whose cdrs are the corresponding number
    ;;> of leap seconds prior to that second. The alist is ordered by
    ;;> decreasing cdr. Both the cars and cdrs are exact integers.
    ;;>
    ;;> As of 2014, the first three pairs of the alist are
    ;;> \scheme{(1341100835 . 25)},
    ;;> \scheme{(1230768034 . 24)}, and
    ;;> \scheme{(1136073633 . 23)}
    ;;> and the last three pairs are
    ;;> \scheme{(94694412 . 2)},
    ;;> \scheme{(78796811 . 1)}, and
    ;;> \scheme{(63072010 . 0)}.

    (define (leap-seconds-before-tai-second-alist)
      (atomic-box-value tai-second-alist-box))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    ;;> \procedure{(set-open-leap-seconds-list-port! \var{p})}
    ;;>
    ;;> The \scheme{set-open-leap-seconds-list-port!} procedure sets the
    ;;> procedure called when the leap-second list is updated to its
    ;;> argument \var{p} and then updates the leap-second list.
    ;;>
    ;;> The procedure \var{p} should
    ;;> return either \scheme{#f}, signifying that no leap-second list is available,
    ;;> or an input port, from which a leap-second list will be read.
    ;;>
    ;;> The leap-second list read from the port must follow the
    ;;> format of the IERS leap-second list.
    ;;> The IERS leap-second list can be found here:
    ;;>
    ;;>   \url{http://hpiers.obspm.fr/iers/bul/bulc/Leap_Second_History.dat}
    ;;>
    ;;> The default procedure attempts to open the file named by the
    ;;> environment variable \code{CLOCK_LEAP_SECONDS_LIST} and returns the
    ;;> port. If the environment variable is not set or if the file does not
    ;;> exist, it return \scheme{#f}.
    ;;>
    ;;> The library updates the leap-second list: when the library is loaded; when the
    ;;> \scheme{set-open-leap-seconds-list-port!} is called; and once per day.
    ;;>
    ;;> The choice of daily updates is motivated by the following
    ;;> considerations. ITU-R TF.460-6, which contains the current
    ;;> definition of UTC, requires that the IERS should announce leap
    ;;> seconds at least eight weeks in advance. Recently the IERS has managed
    ;;> six months of notice, but we should not rely on this.

    (define open-leap-seconds-list-port-box
      (make-atomic-box
       (lambda ()
         (let ((file-name (get-environment-variable file-name-environment-variable)))
           (if file-name
             (open-input-file file-name)
             #f)))))

    (define (open-leap-seconds-list-port)
      (atomic-box-value open-leap-seconds-list-port-box))

    (define (set-open-leap-seconds-list-port! p)
      (atomic-box-value-set! open-leap-seconds-list-port-box p)
      (update-alists! (open-leap-seconds-list-port)))

    (define file-name-environment-variable "CLOCK_LEAP_SECONDS_LIST")

    (define update-interval seconds-per-day)

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    ;;> \procedure{(set-update-exception-handler! \var{p})}
    ;;>
    ;;> The \scheme{set-update-exception-handler!} procedure sets the value of the
    ;;> error handler installed while the leap-second list is updated to \var{p}.
    ;;> The default exception handler simply raises the exception again.

    (define update-exception-handler-box
      (make-atomic-box raise))

    (define (update-exception-handler)
      (atomic-box-value update-exception-handler-box))

    (define (set-update-exception-handler! p)
      (atomic-box-value-set! update-exception-handler-box p)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (begin

    (define utc-day-alist-box    (make-atomic-box '()))
    (define tai-second-alist-box (make-atomic-box '()))

    (define (utc-day-alist->tai-second-alist utc-day-alist)
      (map
       (lambda (p)
         (let* ((utc-day      (car p))
                (leap-seconds (cdr p))
                ;; 10 seconds of the offset are not due to leap seconds.
                (tai-second   (+ (* utc-day seconds-per-day) 10 leap-seconds)))
           (cons tai-second leap-seconds)))
       utc-day-alist))

    (define (update-alists! open-port)
      (with-exception-handler
          (update-exception-handler)
        (lambda ()
          (let ((port (open-port)))
            (when port
              (let* ((new-utc-day-alist (read-leap-seconds-list port))
                     (new-tai-second-alist (utc-day-alist->tai-second-alist new-utc-day-alist)))
                (atomic-box-value-set! utc-day-alist-box  new-utc-day-alist)
                (atomic-box-value-set! tai-second-alist-box new-tai-second-alist)))))))

    (thread-start!
     (make-thread
      (lambda ()
        (let loop ()
          (thread-sleep! update-interval)
          (update-alists! (open-leap-seconds-list-port))
          (loop)))))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    ;; The read-leap-seconds-list procedure reads text from the port
    ;; argument. The text must follow the format of a IERS leap-seconds
    ;; file:
    ;;
    ;;   http://hpiers.obspm.fr/iers/bul/bulc/Leap_Second_History.dat
    ;;
    ;; The procedure returns an alist. The cars of the pairs are the number
    ;; of whole UTC days since 1970-01-01 00:00:00 UTC and the cdrs of the
    ;; pairs are the corresponding number of leap seconds. The alist is
    ;; ordered by decreasing car. The cars and cdrs are exact integers.
    ;;
    ;; TODO: Do not rely on the input file being correctly ordered. Do not
    ;; rely on the input data being exact integers.
    ;;
    ;; TODO: Check known leap seconds.

    (define (read-leap-seconds-list port)

      (define (mjd->utc-day mjd)
        ;; 1970-01-01 00:00:00 UTC corresponds to MJD 40587.
        (- mjd 40587))

      (define (leap-seconds-line->pair line)
        (let* ((line-port         (open-input-string line))
               (mjd               (read line-port))
               (day               (read line-port))
               (month             (read line-port))
               (year              (read line-port))
               (tai-to-utc-offset (read line-port))
               (utc-day           (mjd->utc-day mjd))
               ;; 10 seconds of the offset are not due to leap seconds.
               (leap-seconds      (- tai-to-utc-offset 10)))
          (cons utc-day leap-seconds)))

      (define (leap-seconds-comment-line? line)
        (char=? #\# (string-ref line 0)))

      (define (read-leap-seconds-line port)
        (let ((line (read-line port)))
          (cond
           ((eof-object? line) line)
           ((leap-seconds-comment-line? line) (read-leap-seconds-line port))
           (else line))))

      (let loop ((alist '()))
        (let ((line (read-leap-seconds-line port)))
          (if (eof-object? line)
            alist
            (loop (cons (leap-seconds-line->pair line) alist))))))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (update-alists!
     (lambda ()
       (open-input-string
        (string-append

         ;; These strings are a copy of:
         ;;
         ;;   http://hpiers.obspm.fr/iers/bul/bulc/Leap_Second_History.dat
         ;;
         ;; as of 2014-07-21 UTC.

         "#  Value of TAI-UTC in second valid beetween the initial value until\n"
         "#  the epoch given on the next line. The last line reads that NO\n"
         "#  leap second was introduced since the corresponding date \n"
         "#  Updated through IERS Bulletin C47 issued in January 2014\n"
         "#  \n"
         "#\n"
         "#  File expires on 31 December 2014\n"
         "#\n"
         "#\n"
         "#    MJD        Date        TAI-UTC (s)\n"
         "#           day month year\n"
         "#    ---    --------------   ------   \n"
         "#\n"
         "    41317.0    1  1 1972       10\n"
         "    41499.0    1  7 1972       11\n"
         "    41683.0    1  1 1973       12\n"
         "    42048.0    1  1 1974       13\n"
         "    42413.0    1  1 1975       14\n"
         "    42778.0    1  1 1976       15\n"
         "    43144.0    1  1 1977       16\n"
         "    43509.0    1  1 1978       17\n"
         "    43874.0    1  1 1979       18\n"
         "    44239.0    1  1 1980       19\n"
         "    44786.0    1  7 1981       20\n"
         "    45151.0    1  7 1982       21\n"
         "    45516.0    1  7 1983       22\n"
         "    46247.0    1  7 1985       23\n"
         "    47161.0    1  1 1988       24\n"
         "    47892.0    1  1 1990       25\n"
         "    48257.0    1  1 1991       26\n"
         "    48804.0    1  7 1992       27\n"
         "    49169.0    1  7 1993       28\n"
         "    49534.0    1  7 1994       29\n"
         "    50083.0    1  1 1996       30\n"
         "    50630.0    1  7 1997       31\n"
         "    51179.0    1  1 1999       32\n"
         "    53736.0    1  1 2006       33\n"
         "    54832.0    1  1 2009       34\n"
         "    56109.0    1  7 2012       35\n"))))

    (update-alists! (open-leap-seconds-list-port))))
